Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/comps/widgets/delphi10/filicpnl/filicpnl.pas

Pascal/Delphi Source File | 1996-06-18 | 16.0 KB | 512 lines

unit Filicpnl;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, ShellAPI, ResUnit;

type
  TFileIconPanel = class(TPanel)
  private
    { Private declarations }
  protected                                   { event method procedure.      }
    { Protected declarations }
  public
    FHighlightColor : TColor;                 { This holds bright edge bevel }
    FShadowColor    : TColor;                 { This holds dark edge bevel   }
    FTheIcon : TIcon;                         { This is the display icon    }
    FTheName : String;                        { This is the filename        }
    FTheLabel : TLabel;                       { This is the display label   }
    Oldname : string;
    OldWidth ,
    Oldheight : Integer;
    { Public declarations }
    Selected : Boolean;                       { This holds selection status }
    procedure Paint; override;                { This allows custom painting  }
    procedure GetColorsForFileIcon( TheFile : String;
               var BC , HC , SC , TC : TColor );
    constructor Create(AOwner : TComponent); override; { override create    }
    procedure Initialize( PanelX              ,             { Left          }
                          PanelY              ,             { Top           }
                          PanelWidth          ,             { Width         }
                          PanelHeight         ,             { Height        }
                          PanelBevelWidth     ,             { Bevel Width   }
                          LabelFontSize         : Integer;  { Font size     }
                          PanelColor          ,             { Main color    }
                          PanelHighlightColor ,             { Bright color  }
                          PanelShadowColor    ,             { Dark color    }
                          LabelTextColor        : TColor;   { Text color    }
                          TheFilename         ,             { Filename      }
                          LabelFontName         : String;   { Font name     }
                          LabelFontStyle        : TFontStyles;  { Font style}
                          ExtraData             : Integer       ); virtual;
    destructor Destroy; override;             { override destroy to free    }
    procedure InitTheFIP;
  published
      property TheName : String read FTheName write FTheName;
  end;

procedure Register;

implementation


procedure TFileIconPanel.GetColorsForFileIcon( TheFile : String;
           var BC , HC , SC , TC : TColor );
var AmADir      ,             { Booleans hold file attribs }
    AmAnArchive ,
    AmAVolumeId ,
    AmHidden    ,
    AmReadOnly  ,
    AmSystem      : Boolean;
{ This procedure sets the imported booleans to the file's attributes }
procedure GetFileAttributes( TheFile : String; var IsDirectory ,
           IsArchive , IsVolumeID , IsHidden , IsReadOnly ,
            IsSysFile : Boolean );
var TheResult : Integer; { Traps for error code on VolumeID }
begin
  { Clear the imported flags for default }
  IsDirectory := false;
  IsArchive := false;
  IsVolumeID := false;
  IsHidden := False;
  IsReadOnly := false;
  IsSysFile := false;
  { Make the Dos call }
  TheResult := FileGetAttr( TheFile );
  if TheResult < 0 then
  begin
    { Volume ID returns -2 (?) }
    IsVolumeID := true;
    { It has no other properties }
    exit;
  end;
  { Use AND test to set all other properties }
  if (( TheResult and faDirectory ) = faDirectory ) then IsDirectory := true;
  if (( TheResult and faArchive ) = faArchive ) then IsArchive := true;
  if (( TheResult and faVolumeID ) = faVolumeID ) then IsVolumeID := true;
  if (( TheResult and faReadOnly ) = faReadOnly ) then IsReadOnly := true;
  if (( TheResult and faHidden ) = faHidden ) then IsHidden := true;
  if (( TheResult and faSysFile ) = faSysFile ) then IsSysFile := true;
end;
begin
  if TheFile = 'NO FILE' then
  begin
    BC := clSilver;
    HC := clWhite;
    SC := clGray;
    TC := clBlack;
    exit;
  end;
  { Make the call to internal fileworkbench to set attributes }
  GetFileAttributes( TheFile , AmADir , AmAnArchive , AmAVolumeId ,
   AmHidden , AmReadOnly , AmSystem );
  { Volume ID has no subtypes }
  if AmAVolumeID then
  begin
    BC := clOlive;
    HC := clYellow;
    SC := clBlack;
    TC := clWhite;
    exit;
  end;
  { Check all directory combinations }
  if AmADir then
  begin
    BC := clNavy;
    HC := clBlue;
    SC := clBlack;
    TC := clWhite;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { One HECK of a file! }
          BC := clBlack;
          HC := clSilver;
          SC := clGray;
          TC := clWhite;
        end
        else
        begin { Dir,RO,Hid }
          BC := clMaroon;
          HC := clFuchsia;
          SC := clGreen;
          TC := clWhite;
        end;
      end
      else
      begin { Dir,Hid }
        BC := clPurple;
        HC := clFuchsia;
        SC := clBlack;
        TC := clWhite;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Dir,RO,Sys }
          BC := clMaroon;
          HC := clLime;
          SC := clGreen;
          TC := clWhite;
        end
        else
        begin { Dir,RO }
          BC := clGreen;
          HC := clLime;
          SC := clBlack;
          TC := clWhite;
        end;
      end
      else
      begin
        if AmSystem then
        begin { Dir,Sys }
          BC := clMaroon;
          HC := clRed;
          SC := clBlack;
          TC := clWhite;
        end;
      end;
    end;
  end
  else { Archive Only; check all combinations }
  begin
    BC := clSilver;
    HC := clWhite;
    SC := clGray;
    TC := clBlack;
    if AmHidden then
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { Hid,RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clPurple;
          TC := clBlack;
        end
        else
        begin { RO,Hid }
          BC := clLime;
          HC := clFuchsia;
          SC := clMaroon;
          TC := clBlack;
        end;
      end
      else
      begin { Hid }
        BC := clFuchsia;
        HC := clWhite;
        SC := clPurple;
        TC := clBlack;
      end;
    end
    else
    begin
      if AmReadOnly then
      begin
        if AmSystem then
        begin { RO,Sys }
          BC := clRed;
          HC := clLime;
          SC := clMaroon;
          TC := clBlack;
        end
        else
        begin { RO }
          BC := clLime;
          HC := clWhite;
          SC := clGreen;
          TC := clBlack;
        end;
      end
      else
      begin
        if AmSystem then
        begin { System }
          BC := clRed;
          HC := clWhite;
          SC := clMaroon;
          TC := clBlack;
        end;
      end;
    end;
  end;
end;


procedure TFileIconPanel.InitTheFIP;
var ButtonColor   ,                    { main panel color       }
    ButtonHLColor ,                    { bright panel color     }
    ButtonSColor  ,                    { dark panel color       }
    Textcolor       : TColor;          { label text color       }
    TheWidth , TheHeight : Integer;
begin
  TheWidth := Width;
  if TheWidth < 90 then TheWidth := 90;
  TheHeight := Height;
  if TheHeight < 90 then TheHeight := 90;
  OldWidth := TheWidth;
  Oldheight := TheHeight;
  Width := TheWidth;
  Height := TheHeight;
  GetColorsForFileIcon( TheName , ButtonColor ,
   ButtonHLColor , ButtonSColor , TextColor );
  Initialize( Left , Top , TheWidth , TheHeight , 3 ,
    7 , ButtonColor, ButtonHLColor , ButtonSColor , TextColor , TheName
     , 'MS Serif' , [] , 0 );
  oldName := TheName;
end;

{ Create method for FIP                                }
constructor TFileIconPanel.Create( AOwner : TComponent );
begin
  { call inherited -- VITAL! }
  inherited Create( AOwner );
  Parent := TWinControl( Aowner );
  { create icon and label components, making self owner/displayer }
  FTheIcon := TIcon.Create;
  FTheLabel := TLabel.Create( Self );
  FThelabel.Parent := Self;
  { Set own and labels mouse methods to stored methods }
  { Set alignment and autosize properties of the label }
  FTheLabel.Autosize := false;
  FTheLabel.Alignment := taCenter;
  { Set selected to false }
  Selected := false;
  Height := 80;
  Width := 80;
  TheName := 'NO FILE';
  InitTheFIP;
end;

{ Initialization method for FIP                                         }
procedure TFileIconPanel.Initialize( PanelX              ,
                                     PanelY              ,
                                     PanelWidth          ,
                                     PanelHeight         ,
                                     PanelBevelWidth     ,
                                     LabelFontSize         : Integer;
                                     PanelColor          ,
                                     PanelHighlightColor ,
                                     PanelShadowColor    ,
                                     LabelTextColor        : TColor;
                                     TheFilename         ,
                                     LabelFontName         : String;
                                     LabelFontStyle        : TFontStyles;
                                     ExtraData             : Integer );

var TheLabelHeight ,             { Holder for label pixel height }
    TheLabelWidth    : Integer;  { Holder for label pixel width  }
    TheOtherPChar    : PChar;    { Windows ASCIIZ string         }
begin
  { Set the basic properties based on imported parameters }
  Left := PanelX;
  Top := PanelY;
  Width := PanelWidth;
  Height := PanelHeight;
  Color := PanelColor;
  BevelWidth := PanelBevelWidth;
  FHighlightColor := PanelHighlightColor;
  FShadowColor := PanelShadowColor;
  FTheName := TheFilename;
  { If the ExtraData field is non-0 then a drive is being sent in }
  if ExtraData <> 0 then
  begin
    GetIconForDrive( ExtraData , FTheIcon );
    { The FileNme property is already set up for the caption; use directly }
    FTheLabel.Caption := TheFilename;
    { Set up the hint for later use (make sure to set ShowHint) }
    Hint := 'Change to ' + TheFileName;
    ShowHint := true;
    { Set up all imported label properties and center it for drawing }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end
  else
  begin
    { A file or directory has been sent in; use GetIconForFile to obtain an }
    { icon either from the file, its owner, or a RES file default.          }
    GetIconForFile( FTheName , FTheIcon );
    if FTheName = 'NO FILE' then
    begin
      FTheLabel.Caption := 'NO FILE';
      Hint := 'Not Initialized';
    end
    else
    begin
      { Check for the Backup caption and set it specially }
      if ExtractfileName( FThename ) = '..' then
      begin
        FTheLabel.Caption := '..';
        Hint := 'Up One Level';
      end
      else
      begin
        { Otherwise just get the filename for the label caption }
        { And the full path for the hint (used later.)          }
        FTheLabel.caption := ExtractFileName( UpperCase( FTheName ));
        Hint := FTheName;
      end;
    end;
    { Activate showhint so hints are seen }
    ShowHint := true;
    { Set label properties with imported values and center for display }
    with FTheLabel do
    begin
      Font.Name := LabelFontName;
      Font.Size := LabelFontSize;
      Font.Style := LabelFontStyle;
      Font.Color := LabelTextColor;
      Canvas.Brush.Color := PanelColor;
      Canvas.Font := Font;
      TheLabelHeight := Canvas.Textheight( Caption ) + 4;
      TheLabelWidth := Canvas.Textwidth( Caption ) + 4;
      Left := (( Self.Width - TheLabelWidth ) div 2 ) + 1;
      Top := ((( Round( Self.Height * 0.25 ) - 6 ) - TheLabelHeight) div 2) + 1;
      Top := Top + Round( Self.Height * 0.75 );
      Height := TheLabelHeight;
      Width := TheLabelWidth;
    end;
  end;
end;

{ Destroy method for FIP }
destructor TFileIconPanel.Destroy;
begin
  { free component resources }
  FTheIcon.Free;
  FTheLabel.Free;
  { call inherited -- VITAL! }
  inherited Destroy;
end;

{ Paint method for FIP; overrides normal paint }
procedure TFileIconPanel.Paint;
var
  TheOtherRect   : TRect;   { Holds clientrect   }
  TopColor     ,            { Holds bright color }
  BottomColor    : TColor;  { Holds dark color   }

{ These methods are from Borland Intl., copyright 1995 }
procedure Frame3D(    Canvas       : TCanvas;
                  var TheRect      : TRect;
                      TopColor   ,
                      BottomColor  : TColor;
                      Width        : Integer );

procedure DoRect;
var
  TopRight, BottomLeft: TPoint;
begin
  with Canvas, TheRect do
  begin
    TopRight.X := Right;
    TopRight.Y := Top;
    BottomLeft.X := Left;
    BottomLeft.Y := Bottom;
    Pen.Color := TopColor;
    PolyLine([BottomLeft, TopLeft, TopRight]);
    Pen.Color := BottomColor;
    Dec(BottomLeft.X);
    PolyLine([TopRight, BottomRight, BottomLeft]);
  end;
end;

begin
  Canvas.Pen.Width := 1;
  Dec(TheRect.Bottom); Dec(TheRect.Right);
  while Width > 0 do
  begin
    Dec(Width);
    DoRect;
    InflateRect(TheRect, -1, -1);
  end;
  Inc(TheRect.Bottom); Inc(TheRect.Right);
end;

procedure AdjustColors(Bevel: TPanelBevel);
begin
  TopColor := FHighlightColor;
  if Bevel = bvLowered then TopColor := FShadowColor;
  BottomColor := FShadowColor;
  if Bevel = bvLowered then BottomColor := FHighlightColor;
end;

{ Custom code begins here }
begin
  if OldName <> TheName then InitTheFIP;
  if (( OldWidth <> Width ) or ( OldHeight <> Height )) then InitTheFIP;
  { Get the rectangle of the control with API/method call }
  TheOtherRect := GetClientRect;
  { draw basic rectangle with basic color }
  with Canvas do
  begin
    Brush.Color := Color;
    FillRect(TheOtherRect);
  end;
  { Set up for top "icon" frame  and draw it with frame3d }
  TheOtherRect.Right := Width;
  TheOtherRect.Bottom := Round( Height * 0.75 ) - 6 ;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Do the same for the lower "label" frame }
  TheOtherRect.Top := Round( Height * 0.75 ) - 5;
  TheOtherRect.Left := 0;
  TheOtherRect.Bottom := Height;
  TheOtherRect.Right := Width;
  if BevelOuter <> bvNone then
  begin
    AdjustColors(BevelOuter);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  Frame3D(Canvas, TheOtherRect, Color, Color, BorderWidth);
  if BevelInner <> bvNone then
  begin
    AdjustColors(BevelInner);
    Frame3D(Canvas, TheOtherRect, TopColor, BottomColor, BevelWidth);
  end;
  { Then draw the icon using canvas draw method }
  Canvas.Draw( (( Width - 32 ) div 2 ) + 1 ,
  ((( Round( Height * 0.75 ) - 6 ) - 32 ) div 2 ) + 1 , FTheIcon );
end;


procedure Register;
begin
  RegisterComponents('Widgets', [TFileIconPanel]);
end;

end.